home *** CD-ROM | disk | FTP | other *** search
/ Risc World 9 / Risc World 9.iso / HTML / ISSUE6 / WIMPPROG / Listings / pg203.txt < prev    next >
Text File  |  2005-01-09  |  16KB  |  621 lines
  1.  REM >!RunImage
  2.  REM (C) Martyn Fox
  3.  REM shape drawing program
  4.  REM based on Wimp shell program v0.01
  5.  version$="0.01 (date)"
  6.  ON ERROR SYS "Wimp_CloseDown",task%,&4B534154:REPORT:PRINT" at line ";ERL:END
  7.  SYS "Wimp_Initialise",200,&4B534154,"Shapes" TO ,task%
  8.  PROCinit
  9.  PROCcreateicon
  10.  ON ERROR IF FNerror THEN PROCclose:END
  11.  REPEAT
  12.    PROCpoll
  13.  UNTIL quit%
  14.  PROCclose
  15.  END
  16.  :
  17.  DEFPROCcreateicon
  18.  REM creates the application's icon and puts it on the icon bar
  19.  !b%=-1:b%!4=0:b%!8=0:b%!12=68:b%!16=68:b%!20=&3002
  20.  $(b%+24)="!shapes":SYS"Wimp_CreateIcon",,b% TO i%
  21.  ENDPROC
  22.  :
  23.  DEFPROCclose
  24.  REM tells the Wimp to quit the application
  25.  ON ERROR OFF
  26.  PROClose_fonts
  27.  SYS "Wimp_CloseDown",task%,&4B534154
  28.  ENDPROC
  29.  :
  30.  DEFPROCpoll
  31.  REM main program Wimp polling loop
  32.  SYS "Wimp_Poll",&3831,b% TO r%
  33.  CASE r% OF
  34.    WHEN 1:PROCredraw(b%)
  35.    WHEN 2:SYS "Wimp_OpenWindow",,b%
  36.    WHEN 3:SYS "Wimp_CloseWindow",,b%
  37.    WHEN 6:PROCmouseclick
  38.    WHEN 7:PROCdragend
  39.    WHEN 8:PROCkeypress
  40.    WHEN 9:PROCmenuclick
  41.    WHEN 17,18:PROCreceive
  42.  ENDCASE
  43.  ENDPROC
  44.  :
  45.  DEFPROCmouseclick
  46.  REM handles mouse clicks in response to Wimp_Poll reason code 6
  47.  REM b%!0=mousex,b%!4=mousey:b%!8=buttons:b%!12=window handle (-2 for icon bar):b%!16=icon handle
  48.  CASE b%!12 OF
  49.    WHEN -2:CASE b%!8 OF
  50.      WHEN 2:PROCshowmenu(mainmenu%,!b%-64,96+2*44):REM replace '2' with number of main menu items
  51.      WHEN 4:!b%=main%:SYS "Wimp_GetWindowState",,b%:b%!28=-1:SYS "Wimp_OpenWindow",,b%
  52.    ENDCASE
  53.    WHEN main%:PROCwindow_click
  54.    WHEN options%:PROCopt_box(b%!8,b%!16)
  55.    WHEN saveas%:PROCsavebox
  56.  ENDCASE
  57.  ENDPROC
  58.  :
  59.  DEFPROCget_origin(handle%,RETURN xorig%,RETURN yorig%)
  60.  REM returns coordinates of window work area origin
  61.  LOCAL c%
  62.  c%=FNstack(36)
  63.  !c%=handle%
  64.  SYS "Wimp_GetWindowState",,c%
  65.  xorig%=c%!4-c%!20:yorig%=c%!16-c%!24
  66.  PROCunstack(c%)
  67.  ENDPROC
  68.  :
  69.  DEFFNstack(size%)
  70.  REM allocates temporary memory from stack block
  71.  REM stack must be cleared after use with PROCunstack
  72.  IF stackptr%+size%>stackend%  ERROR 1,"No room in stack"
  73.  stackptr%+=size%
  74.  =stackptr%-size%
  75.  :
  76.  DEFPROCunstack(old_ptr%)
  77.  REM removes temporary memory from stack
  78.  stackptr%=old_ptr%
  79.  IF stackptr%<stack% stackptr%=stack%
  80.  ENDPROC
  81.  :
  82.  DEFFNmake_menu
  83.  REM creates menu block from DATA statements
  84.  LOCAL start%,title$,item$,ul%,tail$,writable%,buffer%,buflen%
  85.  start%=menspc%
  86.  READ title$
  87.  $(start%)=title$
  88.  start%?12=7:REM title foreground colour
  89.  start%?13=2:REM title background colour
  90.  start%?14=7:REM work area foreground colour
  91.  start%?15=0:REM work area background colour
  92.  start%!20=44:REM height of menu items
  93.  start%!24=0:REM gap between items
  94.  width%=LEN(title$)-3
  95.  menspc%+=28
  96.  REPEAT
  97.    READ item$
  98.    IF item$<>"*" THEN
  99.      !menspc%=0
  100.      writable%=FALSE
  101.      ul%=INSTR(item$,"_")
  102.      IF ul% THEN
  103.        tail$=RIGHT$(item$,LEN(item$)-ul%)
  104.        IF INSTR(tail$,"T") !menspc%=!menspc% OR 1:REM tick
  105.        IF INSTR(tail$,"D") !menspc%=!menspc% OR 2:REM dotted line
  106.        IF INSTR(tail$,"W") !menspc%=!menspc% OR 4:writable%=TRUE:READ buffer%:READ buflen%:REM writable icon
  107.        IF INSTR(tail$,"M") !menspc%=!menspc% OR 8:REM generate message
  108.        item$=LEFT$(item$,ul%-1)
  109.      ENDIF
  110.      IF LENitem$>width% width%=LENitem$
  111.      menspc%!4=-1:REM submenu ptr
  112.      IF writable% THEN
  113.        menspc%!8=&0700F121:menspc%!12=buffer%:menspc%!16=-1:menspc%!20=buflen%:$buffer%=item$
  114.        ELSE
  115.        IF LENitem$<12 THEN
  116.          menspc%!8=&07000021:$(menspc%+12)=item$
  117.          ELSE
  118.          menspc%!8=&07000121:menspc%!12=ws%:menspc%!16=-1:menspc%!20=LENitem$+1
  119.          $ws%=item$:ws%+=LENitem$+1
  120.        ENDIF
  121.      ENDIF
  122.      menspc%+=24
  123.    ENDIF
  124.  UNTIL item$="*"
  125.  start%!16=width%*16+32
  126.  !(menspc%-24)=!(menspc%-24) OR &80
  127.  mptr%=menspc%
  128.  =start%
  129.  :
  130.  DEFPROCload_templates
  131.  REM opens window template file, loads and creates window
  132.  SYS "Wimp_OpenTemplate",,"<Shapes$Dir>.Templates"
  133.  REM ****** load and create Info box ******
  134.  SYS "Wimp_LoadTemplate",,stack%,ws%,wsend%,-1,"progInfo",0 TO ,,ws%
  135.  $stack%!(88+32*0+20)=version$
  136.  SYS "Wimp_CreateWindow",,stack% TO info%
  137.  REM ****** load and create main window ******
  138.  SYS "Wimp_LoadTemplate",,stack%,ws%,wsend%,-1,"Main",0 TO ,,ws%
  139.  SYS "Wimp_CreateWindow",,stack% TO main%
  140.  REM ****** load and create Options dialogue box ******
  141.  SYS "Wimp_LoadTemplate",,stack%,ws%,wsend%,-1,"Options",0 TO ,,ws%
  142.  textbuf%=!(stack%+88+32*7+20)
  143.  SYS "Wimp_CreateWindow",,stack% TO options%
  144.  REM ****** load and create Save box ******
  145.  SYS "Wimp_LoadTemplate",,stack%,ws%,wsend%,-1,"xfer_send",0 TO ,,ws%
  146.  savestr%=!(stack%+88+32*2+20)
  147.  SYS "Wimp_CreateWindow",,stack% TO saveas%
  148.  REM ****** end of window creation ******
  149.  SYS "Wimp_CloseTemplate"
  150.  ENDPROC
  151.  :
  152.  DEFPROCattach(menu%,item%,sub%)
  153.  REM attach submenu or dialogue box to main menu
  154.  !(menu%+28+item%*24+4)=sub%
  155.  ENDPROC
  156.  :
  157.  DEFPROCinit
  158.  REM initialisation before polling loop starts
  159.  DIM b% 255,ws% 2047,menspc% 2047,stack% 1023,list% 2047,ptsize% 12,fontname% 50
  160.  $ptsize%=""
  161.  $fontname%="Trinity.Medium"
  162.  wsend%=ws%+2048:stackend%=stack%+1024:stackptr%=stack%:menend%=menspc%+2048:fontlist%=list%+1024
  163.  quit%=FALSE
  164.  !list%=-1:!fontlist%=-1
  165.  colsel%=7
  166.  PROCload_templates
  167.  PROCmenus
  168.  !b%=main%:SYS "Wimp_GetWindowState",,b%:SYS "Wimp_OpenWindow",,b%
  169.  ENDPROC
  170.  :
  171.  DEFPROCreceive
  172.  REM handles messages received from the Wimp with reason codes 17 or 18
  173.  CASE b%!16 OF
  174.    WHEN 0:quit%=TRUE
  175.    WHEN 2:PROCsave
  176.    WHEN 3:PROCload
  177.    WHEN &400C0:PROCmenu_message
  178.  ENDCASE
  179.  ENDPROC
  180.  :
  181.  DEFPROCwindow_click
  182.  REM handles mouse clicks on window
  183.  REM b%!0=mousex,b%!4=mousey:b%!8=buttons:b%!12=window handle (-2 for icon bar):b%!16=icon handle
  184.  CASE b%!8 OF
  185.    WHEN 2:PROCshowmenu(wmenu%,!b%,b%!4)
  186.    WHEN 1:PROCdelete_item
  187.    WHEN 4:PROCadd_item
  188.  ENDCASE
  189.  ENDPROC
  190.  :
  191.  DEFPROCmenus
  192.  REM create menus and attach submenus and dialogue boxes
  193.  PROCmain_menu
  194.  PROCattach(mainmenu%,0,info%)
  195.  PROCwindow_menu
  196.  PROCfont_size_menu
  197.  PROCattach(wmenu%,0,options%)
  198.  PROCattach(wmenu%,2,saveas%)
  199.  PROCattach(wmenu%,3,1)
  200.  PROCattach(wmenu%,4,fmenu%)
  201.  $savestr%="ShapeFile"
  202.  ENDPROC
  203.  :
  204.  DEFPROCshowmenu(menu%,x%,y%)
  205.  REM opens menu at given coordinates
  206.  topmenu%=menu%:topx%=x%:topy%=y%
  207.  SYS "Wimp_CreateMenu",,menu%,x%,y%
  208.  ENDPROC
  209.  :
  210.  DEFPROCmenuclick
  211.  REM handles mouse clicks on menu in response to Wimp_Poll reason code 9
  212.  LOCAL c%,adj%
  213.  c%=FNstack(20)
  214.  SYS "Wimp_GetPointerInfo",,c%
  215.  adj%=(c%!8 AND 1)
  216.  SYS "Wimp_DecodeMenu",,topmenu%,b%,c%
  217.  CASE $c% OF
  218.    WHEN "Quit":quit%=TRUE
  219.    WHEN "Clear":PROCclear
  220.    WHEN "Save":PROCchecksave
  221.    OTHERWISE
  222.      IF LEFT$($c%,5)="Font.":PROCpick_font
  223.  ENDCASE
  224.  IF adj% PROCshowmenu(topmenu%,topx%,topy%)
  225.  PROCunstack(c%)
  226.  ENDPROC
  227.  :
  228.  DEFPROCmain_menu
  229.  REM creates main menu, calling FNmake_menu
  230.  RESTORE +1
  231.  DATA Shapes,Info,Quit,*
  232.  mainmenu%=FNmake_menu
  233.  ENDPROC
  234.  :
  235.  DEFPROCredraw(b%)
  236.  REM redraws window contents
  237.  LOCAL xorig%,yorig%,more%
  238.  PROCget_origin(!b%,xorig%,yorig%)
  239.  SYS "Wimp_RedrawWindow",,b% TO more%
  240.  WHILE more%
  241.    PROCdraw(b%,xorig%,yorig%)
  242.    SYS "Wimp_GetRectangle",,b% TO more%
  243.  ENDWHILE
  244.  ENDPROC
  245.  :
  246.  DEFPROCdraw(b%,xorig%,yorig%)
  247.  REM called when all or part of window needs redrawing
  248.  REM xorig% and yorig% are coordinates of work area origin (top left-hand corner of window work area)
  249.  REM b% points to block:
  250.  REM b%!0  : window handle
  251.  REM b%!4  : visible area minimum x coordinate
  252.  REM b%!8  : visible area minimum y coordinate
  253.  REM b%!12 : visible area maximum x coordinate
  254.  REM b%!16 : visible area maximum y coordinate
  255.  REM b%!20 : scroll x offset relative to work area origin
  256.  REM b%!24 : scroll y offset relative to work area origin
  257.  REM b%!28 : current graphics window minimum x coordinate
  258.  REM b%!32 : current graphics window minimum y coordinate
  259.  REM b%!36 : current graphics window maximum x coordinate
  260.  REM b%!40 : current graphics window maximum y coordinate
  261.  LOCAL coords%,colour%,plot%
  262.  MOVE xorig%,yorig%
  263.  coords%=list%
  264.  WHILE !coords%<>-1
  265.    PROCplot_shape(!coords%,x%,y%,colour%,plot%)
  266.    IF plot%=0 THEN
  267.      PROCtext(xorig%+x%,yorig%-y%,colour%,coords%)
  268.    ELSE
  269.      SYS "Wimp_SetColour",colour%
  270.      PLOT plot%,xorig%+x%,yorig%-y%
  271.      coords%+=4
  272.    ENDIF
  273.  ENDWHILE
  274.  ENDPROC
  275.  :
  276.  DEFPROCplot_shape(word%,RETURN x%,RETURN y%,RETURN colour%,RETURN plot%)
  277.  REM returns parameters of object to be plotted, decoded from word%
  278.  x%=(word% AND &3FF)*4:y%=(word%>>12) AND &FFC
  279.  colour%=(word%>>10) AND &F
  280.  plot%=(word%>>24) AND &FF
  281.  ENDPROC
  282.  :
  283.  DEFPROCwindow_menu
  284.  RESTORE +1
  285.  DATA Shapes,Options,Clear,Save,Font_M,Font size,*
  286.  wmenu%=FNmake_menu
  287.  ENDPROC
  288.  :
  289.  DEFFNicon_state(window%,icon%)
  290.  LOCAL c%
  291.  c%=FNstack(40)
  292.  !c%=window%
  293.  c%!4=icon%
  294.  SYS "Wimp_GetIconState",,c%
  295.  PROCunstack(c%)
  296.  =((c%!24) AND (1<<21))<>0
  297.  :
  298.  DEFPROCadd_item
  299.  x%=!b%:y%=b%!4
  300.  PROCget_origin(main%,xorig%,yorig%)
  301.  coords%=FNend
  302.  IF coords%<list%+1020 THEN
  303.  CASE TRUE OF
  304.    WHEN FNicon_state(options%,0):plot%=4:REM MOVE
  305.    WHEN FNicon_state(options%,1):plot%=5:REM DRAW
  306.    WHEN FNicon_state(options%,2):plot%=157:REM CIRCLE FILL
  307.    WHEN FNicon_state(options%,3):plot%=101:REM RECTANGLE FILL
  308.    WHEN FNicon_state(options%,6):plot%=0:REM TEXT
  309.    OTHERWISE:plot%=4:REM MOVE - all icons deselected
  310.  ENDCASE
  311.  !coords%=(((x%-xorig%) AND &FFC) DIV 4)+((yorig%-y%) AND &FFC)*(1<<12)+(colsel% AND &F)*(1<<10)
  312.  coords%?3=plot%
  313.  IF plot%=0 PROCadd_text(coords%)
  314.  coords%!4=-1
  315.  PROCforce_redraw(main%)
  316.  ENDIF
  317.  ENDPROC
  318.  :
  319.  DEFFNend
  320.  LOCAL n%
  321.  n%=list%
  322.  WHILE !n%<>-1
  323.    n%+=4
  324.  ENDWHILE
  325.  =n%
  326.  :
  327.  DEFPROCforce_redraw(window%)
  328.  LOCAL c%
  329.  c%=FNstack(36)
  330.  !c%=window%
  331.  SYS "Wimp_GetWindowState",,c%
  332.  SYS "Wimp_ForceRedraw",-1,c%!4,c%!8,c%!12,c%!16
  333.  PROCunstack(c%)
  334.  ENDPROC
  335.  :
  336.  DEFPROCdelete_item
  337.  coords%=FNend
  338.  IF coords%>list% THEN
  339.    coords%-=4
  340.    IF (!coords% AND &FF000000)=0 coords%-=!coords%:SYS "Font_LoseFont",coords%!4
  341.    !coords%=-1
  342.  ELSE
  343.    VDU 7
  344.  ENDIF
  345.  PROCforce_redraw(main%)
  346.  ENDPROC
  347.  :
  348.  DEFPROCopt_box(button%,icon%)
  349.  CASE icon% OF
  350.    WHEN 0,1,2,3,6:
  351.    WHEN 5:
  352.      !b%=options%:b%!4=4
  353.      SYS "Wimp_GetIconState",,b%
  354.      colsel%=(b%!24)>>28
  355.      IF button%=4 SYS "Wimp_CreateMenu",,-1
  356.    OTHERWISE
  357.      !b%=options%:b%!4=icon%
  358.      SYS "Wimp_GetIconState",,b%
  359.      b%!4=4:b%!8=(b%!24) AND &F<<28:b%!12=&F<<28
  360.      SYS "Wimp_SetIconState",,b%
  361.  ENDCASE
  362.  ENDPROC
  363.  :
  364.  DEFPROCclear
  365.  PROClose_fonts
  366.  !list%=-1
  367.  PROCforce_redraw(main%)
  368.  ENDPROC
  369.  :
  370.  DEFFNerror
  371.  !b%=ERR
  372.  CASE !b% OF
  373.  WHEN 1<<30:err_str$="":box%=3
  374.  OTHERWISE:err_str$=" at line "+STR$ERL:box%=2
  375.  ENDCASE
  376.  $(b%+4)=REPORT$+err_str$+CHR$0
  377.  SYS "Wimp_ReportError",b%,box%,"Shapes" TO ,response%
  378.  =(response%=2)
  379.  :
  380.  DEFPROCload
  381.  IF b%!40<>&012 ERROR 1<<30,"Filetype not recognised"
  382.  PROCterm(b%+44)
  383.  PROClose_fonts
  384.  SYS "XOS_CLI","LOAD "+$(b%+44)+" "+STR$~list% TO err%;flags%
  385.  IF (flags% AND 1)<>0 !err%=1<<30:SYS "OS_GenerateError",err%
  386.  b%!12=b%!8
  387.  b%!16=4:REM Message_DataLoadAck
  388.  SYS "Wimp_SendMessage",17,b%,b%!4
  389.  $savestr%=$(b%+44)
  390.  PROCupdate_fonts
  391.  !b%=main%
  392.  SYS "Wimp_GetWindowState",,b%
  393.  IF ((b%!32) AND 1<<16)=0 THEN
  394.    SYS "Wimp_OpenWindow",,b%
  395.  ELSE
  396.    PROCforce_redraw(main%)
  397.  ENDIF
  398.  ENDPROC
  399.  :
  400.  DEFPROCterm(a%)
  401.  LOCAL n%
  402.  WHILE a%?n%>31
  403.    n%+=1
  404.  ENDWHILE
  405.  a%?n%=13
  406.  ENDPROC
  407.  :
  408.  DEFPROCsavebox
  409.  CASE b%!16 OF
  410.    WHEN 0:IF b%!8=1 OR b%!8=4 THEN PROCchecksave
  411.    WHEN 1:IF b%!8=16 OR b%!8=64 THEN PROCdrag(b%!12,1)
  412.  ENDCASE
  413.  ENDPROC
  414.  :
  415.  DEFPROCdrag(window%,icon%)
  416.  LOCAL c%
  417.  c%=FNstack(56)
  418.  PROCget_origin(window%,xorig%,yorig%)
  419.  !c%=window%:c%!4=icon%
  420.  SYS "Wimp_GetIconState",,c%
  421.  xmin%=xorig%+c%!8:ymin%=yorig%+c%!12:xmax%=xorig%+c%!16:ymax%=yorig%+c%!20
  422.  c%!4=5:REM drag type
  423.  c%!8=xmin%:REM coordinates of drag box
  424.  c%!12=ymin%
  425.  c%!16=xmax%
  426.  c%!20=ymax%
  427.  c%!24=0:REM screen min x
  428.  c%!28=0:REM screen min y
  429.  c%!32=4096:REM screen max x
  430.  c%!36=3072:REM screen max y
  431.  SYS "Wimp_DragBox",,c%
  432.  PROCunstack(c%)
  433.  ENDPROC
  434.  :
  435.  DEFPROCdragend
  436.  SYS "Wimp_GetPointerInfo",,b%
  437.  b%!20=b%!12:REM destination window handle
  438.  b%!24=b%!16:REM destination icon handle
  439.  b%!28=b%!0:REM destination x coordinate
  440.  b%!32=b%!4:REM destination y coordinate
  441.  b%!36=FNend+4-list%:REM length of data
  442.  a$=$savestr%:REM get leafname
  443.  WHILE INSTR(a$,".")<>0
  444.    n%=INSTR(a$,".")
  445.    a$=MID$(a$,n%+1)
  446.  ENDWHILE
  447.  $(b%+44)=a$:REM leafname of file
  448.  !b%=44+((LENa$+1) DIV 4)*4:REM length of block
  449.  IF ((LENa$+1) MOD 4)<>0 !b%+=4
  450.  b%!12=0:REM your_ref for original message
  451.  b%!16=1:REM Message_DataSave
  452.  SYS "Wimp_SendMessage",18,b%,b%!20
  453.  ENDPROC
  454.  :
  455.  DEFPROCsave
  456.  PROCterm(b%+44)
  457.  $savestr%=$(b%+44)
  458.  PROCsave2
  459.  b%!12=b%!8
  460.  b%!16=3:REM Message_DataLoad
  461.  SYS "Wimp_SendMessage",18,b%,b%!20
  462.  ENDPROC
  463.  :
  464.  DEFPROCsave2
  465.  n%=FNend2+4
  466.  SYS "XOS_CLI","SAVE "+$savestr%+" "+STR$~list%+" "+STR$~n% TO err%;flags%
  467.  IF (flags% AND 1)<>0 !err%=1<<30:SYS "OS_GenerateError",err%
  468.  SYS "XOS_CLI","SETTYPE "+$savestr%+" 012" TO err%;flags%
  469.  IF (flags% AND 1)<>0 !err%=1<<30:SYS "OS_GenerateError",err%
  470.  SYS "Wimp_CreateMenu",,-1
  471.  ENDPROC
  472.  :
  473.  DEFPROCchecksave
  474.  IF INSTR($savestr%,"::")<>0 AND INSTR($savestr%,"$.")<>0 THEN
  475.    PROCsave2
  476.  ELSE
  477.    SYS "Wimp_CreateMenu",,-1
  478.    ERROR 1<<30,"To save, drag the icon to a directory display"
  479.  ENDIF
  480.  ENDPROC
  481.  :
  482.  DEFPROCkeypress
  483.  REM processes keypresses in response to Wimp_Poll reason code 8
  484.  IF b%!24=13 THEN
  485.    !b%=saveas%
  486.    SYS "Wimp_GetWindowState",,b%
  487.    IF (b%!32 AND 1<<16)<>0 THEN PROCchecksave
  488.  ELSE
  489.    SYS "Wimp_ProcessKey",b%!24
  490.  ENDIF
  491.  ENDPROC
  492.  :
  493.  DEFPROCtext(x%,y%,col%,RETURN coords%)
  494.  fh%=coords%!4:coords%+=8
  495.  SYS "Wimp_SetFontColours",,1,col%
  496.  SYS "Font_SetFont",fh%
  497.  SYS "Font_Paint",,coords%,%10000,x%,y%
  498.  WHILE ?coords%>=32:coords%+=1:ENDWHILE
  499.  coords%+=1:WHILE (coords% MOD 4)<>0:coords%+=1:ENDWHILE
  500.  coords%+=4
  501.  ENDPROC
  502.  :
  503.  DEFPROCadd_text(RETURN coords%)
  504.  LOCAL n%,pt%,fonth%
  505.  PROCterm(textbuf%)
  506.  IF coords%+LEN$textbuf%>list%+984:VDU 7:coords%-=4:ENDPROC
  507.  pt%=VAL$ptsize%*16:IF pt%=0 pt%=14*16
  508.  SYS "Font_FindFont",,fontname%,pt%,pt% TO fonth%
  509.  PROCadd_font(fonth%,pt%)
  510.  coords%!4=fonth%
  511.  $(coords%+8)=$textbuf%
  512.  n%=LEN$textbuf%+8
  513.  coords%?n%=0
  514.  n%+=1
  515.  WHILE n% MOD 4<>0:n%+=1:ENDWHILE
  516.  coords%!n%=n%
  517.  coords%+=n%
  518.  ENDPROC
  519.  :
  520.  DEFPROCfont_size_menu
  521.  RESTORE+1
  522.  DATA Font size,_W,ptsize%,12,*
  523.  fmenu%=FNmake_menu
  524.  ENDPROC
  525.  :
  526.  DEFPROCmenu_message
  527.  CASE TRUE OF
  528.    WHEN topmenu%=wmenu% AND b%!32=3 AND b%!36=-1:PROCfont_list(b%!24,b%!28)
  529.  ENDCASE
  530.  ENDPROC
  531.  :
  532.  DEFPROCfont_list(menx%,meny%)
  533.  buf%=menspc%
  534.  SYS "Font_ListFonts",,0,%101<<19,,0,,0 TO ,,,bsize1%,,bsize2%
  535.  IF bsize1%>menend%-buf% ERROR 1<<30,"Not enough space to list all the fonts"
  536.  IF bsize2%>wsend%-ws% ERROR 1<<30,"Insufficient indirected workspace to list all fonts"
  537.  SYS "Font_ListFonts",,buf%,%101<<19,menend%-buf%,ws%,wsend%-ws%,fontname%
  538.  PROCattach(wmenu%,3,buf%)
  539.  SYS "Wimp_CreateSubMenu",,buf%,menx%,meny%
  540.  ENDPROC
  541.  :
  542.  DEFPROCpick_font
  543.  SYS "Wimp_DecodeMenu",,buf%,b%+4,fontname%
  544.  SYS "Font_ListFonts",,buf%,%101<<19,menend%-buf%,ws%,wsend%-ws%,fontname%
  545.  ENDPROC
  546.  :
  547.  DEFPROCadd_font(h%,p%)
  548.  LOCAL n%,found%
  549.  found%=FALSE
  550.  n%=fontlist%
  551.  WHILE !n%<>-1
  552.    IF !n%=h% found%=TRUE
  553.    n%+=8
  554.    WHILE ?n%>=32:n%+=1:ENDWHILE
  555.    n%+=1
  556.    WHILE n% MOD 4<>0 n%+=1:ENDWHILE
  557.  ENDWHILE
  558.  IF NOT found% THEN
  559.    !n%=h%:n%!4=p%:$(n%+8)=$fontname%
  560.    n%+=8
  561.    WHILE ?n%>=32:n%+=1:ENDWHILE
  562.    n%+=1
  563.    WHILE n% MOD 4<>0 n%+=1:ENDWHILE
  564.    !n%=-1
  565.  ENDIF
  566.  ENDPROC
  567.  :
  568.  DEFFNend2
  569.  LOCAL n%
  570.  n%=fontlist%
  571.  WHILE !n%<>-1
  572.    n%+=4
  573.  ENDWHILE
  574.  =n%
  575.  :
  576.  DEFPROCupdate_fonts
  577.  LOCAL n%
  578.  n%=fontlist%
  579.  WHILE !n%<>-1 AND n%<fontlist%+1024
  580.    oldh%=!n%
  581.    SYS "XFont_FindFont",,n%+8,n%!4,n%!4 TO newh%;flags%
  582.    IF (flags% AND 1)<>0:err%=newh%:!err%=1<<30:PROCclear:SYS "OS_GenerateError",err%
  583.    PROCupdate_plot_list(oldh%,newh%)
  584.    !n%=newh%
  585.    n%+=8
  586.    WHILE ?n%>=32:n%+=1:ENDWHILE
  587.    n%+=1
  588.    WHILE n% MOD 4<>0:n%+=1:ENDWHILE
  589.  ENDWHILE
  590.  ENDPROC
  591.  :
  592.  DEFPROCupdate_plot_list(old%,new%)
  593.  LOCAL n%
  594.  n%=FNend
  595.  WHILE n%>list%
  596.    IF (!n% AND &FF000000)<>0 THEN
  597.      n%-=4
  598.    ELSE
  599.      n%-=!n%
  600.      IF n%!4=old% n%!4=new%
  601.      IF n%>list% n%-=4
  602.    ENDIF
  603.  ENDWHILE
  604.  ENDPROC
  605.  :
  606.  DEFPROClose_fonts
  607.  LOCAL n%
  608.  n%=FNend
  609.  WHILE n%>list%
  610.    IF (!n% AND &FF000000)<>0 THEN
  611.      n%-=4
  612.    ELSE
  613.      n%-=!n%
  614.      SYS "Font_LoseFont",n%!4
  615.    IF n%>list% n%-=4
  616.    ENDIF
  617.  ENDWHILE
  618.  !fontlist%=-1
  619.  ENDPROC
  620.  :
  621.